﻿#!perl

use strict;
use warnings;

package IdItem;
use constant {
	KEYWORD	=> 1,
	OBJECT	=> 2,
	PROPERTY => 4,
	OPERATOR => 8,
	SEPAR => 16,
	REMARK => 32,
	STRING => 64,
	NUMBER => 128,
	ID => 256,
    REGEXP => 512,
	BLANK => 1024
};

our $Colors = {
	KEYWORD, '#0080c0',
	OBJECT, '#ff0000',
	PROPERTY, '#ff8040',
	OPERATOR, '#008000',
	SEPAR, '#800000',
	REMARK, '#008080',
	STRING, '#949494',
	NUMBER, '#ff0000',
	ID, '#000000',
    REGEXP, '#004000'
};

sub new {
	my $class = shift;
	my $self = {
		type => shift,
		value => shift
	};
	bless $self, $class;
	return $self;
}

package  Parse;
my $debug = 0;

my $addToTree = sub {
    my ($root, $id_refer, $type) = @_;
    my $ori_root = $root;
    for my $id (@{$id_refer}) {
        $root = $ori_root;
        my @chars = split //, $id;
        for(0..$#chars - 1) {
            my $char = $chars[$_];
            unless (exists $root->{$char}) {
                $root->{$char} = [0, {}];
            }
            $root = $root->{$char}->[1];
        }
        my $last_char = $chars[$#chars];
        if (exists $root->{$last_char}) {
            my $ori_type = $root->{$last_char}->[0];
            $root->{$last_char}->[0] |= $type;
        } else {
            $root->{$last_char} = [$type, {}];
        }
    }
};

my $init_config = sub {
	my ($self, $config_filename) = @_;
	my $refer = undef;
	my $word_type;
	open FH, $config_filename or die "open file $config_filename failed:$!";
	while (<FH>) {
		next if /^\s+$/;
		if (my ($word_type_temp) = m#^//(\w+)$#) {
			if ($self->{$word_type_temp}) {
				$refer = $self->{$word_type_temp};
				$word_type = $word_type_temp;
			}
		} else {
			if ($refer) {
				my @words = split /\s+/;
				push @{$refer}, @words;
                #print "get $word_type: @words\n";
			}
		}
	}
    my $root = {};
    &$addToTree($root, $self->{keywords}, IdItem::KEYWORD);
    &$addToTree($root, $self->{objects}, IdItem::OBJECT);
    &$addToTree($root, $self->{properties}, IdItem::PROPERTY);
    &$addToTree($root, $self->{operators}, IdItem::OPERATOR);
    #print Data::Dump::dump(%{$root});
    $self->{tree} = $root;
	close FH;
};


sub new {
	my $self = {
		keywords	=> [],
		objects => [],
		properties => [],
		operators => [],
		separs => [],
		tab_space_num => 3,
		index => 0,
		length => 0,
		error => 0,
		content => '',
		id_vector => []
	};
	my ($class, $lang_type) = (shift, shift);
	my $config_filename = "lang/$lang_type.txt";
	-T $config_filename or die "can't find file $config_filename";
	bless $self, $class;
	$self->$init_config($config_filename);
    $self->run(shift) if (scalar @_);
	return $self;
}

sub dump {
    my $self = shift;
    for my $id (@{$self->{id_vector}}) {
        print "type:$id->{type}\tvalue:$id->{value}\n";
    }
}

sub is_alpha {
	my $asc = ord shift;
	#$ . a-z A-Z
	$asc==36 || $asc == 95 || ($asc >= 97 && $asc <= 122) || ($asc >= 65
&& $asc <= 90);
}

sub is_num {
	my $asc = ord shift;
	$asc >= 48 && $asc <= 57;
}

sub is_blank {
	my $char = shift;
    return 0 unless defined $char;
	index(" \t\r\n", $char) != -1;
}

sub in_array {
    my ($search_for, $needle) = @_;
    for (@{$search_for}) {
        return 1 if $_ eq $needle;
    }
    return 0;
}

sub check_type {
    my ($self, $value, $type) = @_;
    my $root = $self->{tree};
    my @chars = split //, $value;
    my $ok = 1;
    for (0..$#chars-1) {
        my $char = $chars[$_];
        unless (exists $root->{$char}) {
            $ok = 0;
            last;
        }
        $root = $root->{$char}->[1];
    }
    return 1 if ($ok && exists($root->{$chars[$#chars]}) &&
($root->{$chars[$#chars]}->[0] & $type));
    return 0;
}

sub run {
	my ($self, $content) = @_;
    $self->{id_vector} = [];
	my @chars = split //, $content;
	$self->{length} = scalar @chars;
	$self->{index} = -1;
	$self->{content} = \@chars;
	my $separs = join '', @{$self->{separs}};
	while (1) {
        print "$self->{index}\n" if $debug;
		last if $self->{index} >= $self->{length};
		my $char = $self->get_next_char;
        last unless defined $char;

		if (is_blank($char)) {
            $self->do_blank($char);
		} elsif (is_alpha($char)) {
            $self->do_identifier($char);
		} elsif (is_num($char)) {
            $self->do_num($char);
		} elsif ($char eq "'" || $char eq '"') {
            $self->do_string($char);
		} elsif ($char eq '/') {
            if ($self->next_char eq '/' || $self->next_char eq '*') {
                $char .= $self->get_next_char;
                $self->do_remark($char);
            } else {
                if ($self->is_regexp()) {
                    $self->do_regexp($char);
                } else {
                    $self->do_operator($char);
                }
            }
		} elsif (index($separs, $char) != -1) {
            $self->do_separ($char);
		} else {
            $self->do_operator($char);
		}
	}
}

sub pre_char {
	my $self = shift;
	$self->{content}->[$self->{index} - 1];
}

sub next_char {
	my $self = shift;
	if ($self->{index} + 1 < $self->{length}) {
		return $self->{content}->[$self->{index} + 1];
	}
    undef;
}

sub get_next_char {
	my $self = shift;
	if ($self->{index} + 1 < $self->{length}) {
        print "get char : '" . $self->{content}->[$self->{index} + 1] . "'\n" if
$debug;
		return $self->{content}->[++$self->{index}];
	}
    undef;
}

sub do_blank {
    print "do_blank\n" if $debug;
	my ($self, $char) = @_;
	while (defined($self->next_char) and is_blank($self->next_char)) {
        $char .= $self->get_next_char;
	}
	push @{$self->{id_vector}}, IdItem::->new(IdItem::BLANK, $char);
    print "do_blank end\n" if $debug;
}

sub do_string {
    print "do_string\n" if $debug;
	my ($self, $char) = @_;
	my $type = $char;
	my $value = $char;
	while (1) {
		$char = $self->get_next_char;
		unless (defined $char) {
			$self->{error} = 1;
			return;
		}
		$value .= $char;
		if ($char eq $type && $self->pre_char ne '\\') {
			push @{$self->{id_vector}}, IdItem::->new(IdItem::STRING, $value);
			return;
		}
	}
    print "do_string end\n" if $debug;
}

sub do_remark {
    print "do_remark\n" if $debug;
	my ($self, $char) = @_;
	my ($type, $value) = ($char, $char);
	if ($type eq '/*') {
		while (1) {
			$char = $self->get_next_char;
			unless (defined $char) {
                $self->{error} = 1;
				return;
			}
			$value .= $char;
			if ($char eq '*' and $self->next_char eq '/') {
				$value .= $self->get_next_char;
				last;
			}
		}
	} else {
		while (1) {
			$char = $self->get_next_char;
			unless (defined $char) {
                #$self->{error} = 1;
                push @{$self->{id_vector}}, IdItem::->new(IdItem::REMARK, $value);
				return;
			}
			if (is_blank($char)) {
				if ($char eq "\r" or $char eq "\n") {
					$self->{index}--;
					last;
				}
			}
			$value .= $char;
		}
	}
	push @{$self->{id_vector}}, IdItem::->new(IdItem::REMARK, $value);
    print "do_remark end\n" if $debug;
}

sub is_regexp {
    my $self = shift;
    my $last_index = $#{$self->{id_vector}};
    return 1 if ($last_index == -1);
    my $id = $self->{id_vector}->[$last_index];
    if ($id->{type} == IdItem::BLANK) {
        return 1 if ($last_index == 0);
        $id = $self->{id_vector}->[$last_index - 1];
    }
    if ($id->{value} eq ';' or $id->{value} eq '(' or $id->{value} eq '=') {
        return 1;
    }
    return 0;
}

sub do_regexp {
    print "do_regexp\n" if $debug;
    my ($self, $char) = @_;
    my $value = $char;
    while (1) {
        $char = $self->get_next_char;
        unless (defined $char) {
            $self->{error} = 1;
            return;
        }
        $value .= $char;
        last if $char eq '/' and $self->pre_char ne "\\";
    }
    while (1) {
        $char = $self->next_char;
        if (defined $char and is_alpha $char) {
            $value .= $self->get_next_char;
        } else {
            last;
        }
    }
    push @{$self->{id_vector}}, IdItem::->new(IdItem::REGEXP, $value);
    print "do_regexp end\n" if $debug;
}

sub do_num {
    print "do_num\n" if $debug;
	my ($self, $char) = @_;
	my $value = $char;
	while (1) {
		$char = $self->get_next_char;
		unless (defined $char) {
            push @{$self->{id_vector}}, IdItem::->new(IdItem::NUMBER, $value);
			return;
		}
		unless (is_num($char)) {
			$self->{index}--;
			push @{$self->{id_vector}}, IdItem::->new(IdItem::NUMBER, $value);
            last;
		}
		$value .= $char;
	}
    print "end do_num\n" if $debug;
}

sub do_separ {
    print "do_separ\n" if $debug;
	my ($self, $char) = @_;
	push @{$self->{id_vector}}, IdItem::->new(IdItem::SEPAR, $char);
    print "end do_separ\n" if $debug;
}

sub do_operator {
    print "do_operator\n" if $debug;
	my ($self, $char) = @_;
    my $value = $char;
	if (is_alpha($char)) {
        push @{$self->{id_vector}}, IdItem::->new(IdItem::OPERATOR, $char);
        return;
    }
    while (1) {
        $char = $self->get_next_char;
        unless (defined $char) {
            last;
        }
        #if (!in_array($self->{operators}, $char)) {
        if (!$self->check_type($value.$char, IdItem::OPERATOR)) {
            $self->{index}--;
            last;
        }
        $value .= $char;
    }
    push @{$self->{id_vector}}, IdItem::->new(IdItem::OPERATOR, $value);
    print "end do_operator\n" if $debug;
}

sub do_identifier {
    print "do_identifier\n" if $debug;
    my ($self, $char) = @_;
    my $value = $char;
    while (1) {
        $char = $self->get_next_char;
        unless(defined $char) {
            last;
        }
        if (is_alpha($char) || $char eq '$' || is_num($char)) {
            $value .= $char;
        } else {
            $self->{index}--;
            last;
        }
    }
    my $type = undef;

    #if (in_array($self->{operators}, $value)) {
    if ($self->check_type($value, IdItem::OPERATOR)) {
        $self->do_operator($value);
        return;
    #} elsif (in_array($self->{keywords}, $value)) {
    } elsif ($self->check_type($value, IdItem::KEYWORD)) {
        $type = IdItem::KEYWORD;
    #} elsif (in_array($self->{objects}, $value)) {
    } elsif ($self->check_type($value, IdItem::OBJECT)) {
        $type = IdItem::OBJECT;
    #} elsif (in_array($self->{properties}, $value)) {
    } elsif ($self->check_type($value, IdItem::PROPERTY)) {
        $type = IdItem::PROPERTY;
    } else {
        $type = IdItem::ID;
    }

    push @{$self->{id_vector}}, IdItem::->new($type, $value);
    print "end do_identifier\n" if $debug;
}

sub get_item_html_start {
    my $type = shift;
    return '' if $type == IdItem::BLANK;
    return '<b class="c' . $type . '">';
}

sub get_item_html_end {
    my $type = shift;
    return '' if $type == IdItem::BLANK;
    return '</b>';
}

sub html_encode {
    $_ = shift;
    s{(\t| |<|>)}{$1 eq "\t" ? '&nbsp;' x 4 : ($1 eq ' ' ? '&nbsp;' : ($1 eq '<' ? '&lt;' : '&gt;'))}geo;
    return $_;
}

sub to_html {
    my $self = shift;
    my @html = ();

    push @html, '<ol><li>';
    for my $id (@{$self->{id_vector}}) {
        my $type = $id->{type};
        my $value = $id->{value};
        my ($start, $end) = (get_item_html_start($type), get_item_html_end($type));

        if ($type == IdItem::REMARK) {
            $value = html_encode($value);
            $value =~ s#\r?\n#$end</li><li>$start#go;
            push @html, $start . $value . $end;
        } elsif ($type == IdItem::BLANK) {
            $value = html_encode($value);
            $value =~ s#\r?\n#</li><li>#go;
            push @html, $value;
        } elsif ($type == IdItem::STRING) {
        	$value = html_encode($value);
        	push @html, $start . $value . $end;	
        } else {
            push @html,  $start . $value . $end;
        }
    }
    my $last_html = $html[$#html];
    my $last_id = $self->{id_vector}->[$#{$self->{id_vector}}];
    if ($last_id->{type} != IdItem::BLANK) {
        push @html, get_item_html_end($last_id->{type});
    }
    if ($last_html !~ m#</li>$#) {
        push @html, '</li>';
    }
    push @html, '</ol>';
    return join "", @html;
}
1;
